home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TBUTIL1.LZH / UT-MOD02.INC < prev    next >
Text File  |  1984-08-30  |  9KB  |  258 lines
  1. procedure Beep(Tone,Duration : integer);
  2.  begin
  3.    Sound(Tone); Delay(Duration); NoSound;
  4.  end;
  5.  
  6. procedure Say_Cap_Num;
  7.    { Display Caps, Num, Insert in inverse video on line 25 of Video }
  8.  var  Value  : integer;
  9.  begin
  10.      Value := Mem[0000:1047];      { test for caps, numbers, & cursor cntrl }
  11.      gotoXY(65,25);
  12.      Case Value of
  13.        0   : begin LowVideo; write('               '); Inserton:= false; end;
  14.        32  : begin LowVideo; write('     '); InvVideo('NUM');
  15.                    Clreol; InsertOn:= false; end;
  16.        64  : begin InvVideo('CAPS'); Clreol;
  17.                    InsertOn:= false; end;
  18.        96  : begin InvVideo('CAPS'); write(' '); InvVideo('NUM');
  19.                    Clreol; InsertOn:=false; end;
  20.        128 : begin LowVideo; write('         ');
  21.                    InvVideo('Insert');InsertOn:=true; end;
  22.        160 : begin LowVideo; write('     '); InvVideo('NUM');write(' ');
  23.                    InvVideo('Insert'); InsertOn:=true; end;
  24.        192 : begin InvVideo('CAPS'); write('     ');
  25.                    InvVideo('Insert'); InsertOn:=true; end;
  26.        224 : begin InvVideo('CAPS'); write(' ');InvVideo('NUM'); write(' ');
  27.                    InvVideo('Insert'); InsertOn:= true; end;
  28.      end; { Case }
  29.   end;
  30.  
  31. procedure Set_Cap_Num(Caps,Num,Insert : Char);
  32.    { Set the Cap Lock, Number Lock, and Ins Keys as desired }
  33.  var J : integer;
  34.  begin
  35.   if Insert='I' then J:=128 else J:=0;
  36.   Case Caps of
  37.     'C': begin if Num='N' then  MemW[0000:1047]:= 96+J
  38.                 else            MemW[0000:1047]:= 64+J;
  39.          end;
  40.     ' ': begin if Num='N' then  MemW[0000:1047]:= 32+J
  41.                 else            MemW[0000:1047]:=  0+J;
  42.          end;
  43.   end; { Case }
  44.  end;
  45.  
  46. {.pa}
  47. procedure Ck_edit_key(var Ch: Char);
  48.    { test for an IBM Cursor control or Function key }
  49. begin
  50.   read(kbd,Ch);
  51.   begin {see if IBM specific key pressed}
  52.     case Ch of
  53.       'H': Ch:=^E    ;  { up-arrow  }
  54.       'P': Ch:=^X    ;  { dn-arrow  }
  55.       'M': Ch:=^D    ;  { rt-arrow  }
  56.       'K': Ch:=^S    ;  { left-arr  }
  57.       'S': Ch:=#127  ;  { Del       }
  58.       'R': Ch:=^V    ;  { insert    }
  59.       'G': Ch:=^G    ;  { Home      }
  60.       'O': Ch:=^O    ;  { End       }
  61.       'I': Ch:=^R    ;  { Pg-Up     }
  62.       'Q': Ch:=#00   ;  { Pg-Dn     }
  63.       ';': Ch:=^a    ;  { F1        }
  64.       '<': Ch:=^b    ;  { F2        }
  65.       '=': Ch:=^c    ;  { F3        }
  66.       '>': Ch:=^d    ;  { F4        }
  67.       '?': Ch:=^e    ;  { F5        }
  68.       '@': Ch:=^f    ;  { F6        }
  69.       'A': Ch:=^g    ;  { F7        }
  70.       'B': Ch:=^h    ;  { F8        }
  71.       'C': Ch:=^i    ;  { F9        }
  72.       'D': Ch:=^j    ;  { F10       }
  73.     end;   {Case Ch}
  74.   end;   {IBM check}
  75. end;  {Ck_edit_key}
  76.  
  77. procedure Get_Template(Template_num:integer; var template: str80);
  78.    { Templates are specified by the Programmer }
  79.  begin
  80.   Case Template_num of
  81.     1 : template := '(___) ___-____';
  82.     2 : template := '__/__/__';
  83.   end;
  84.  end;
  85.  
  86. procedure Input(Typ: Char          ;    { Type of input        }
  87.                 Default: str255   ;    { Default string       }
  88.                 Col,Row: integer   ;    { Where start line     }
  89.                 Mlen: integer      ;    { Max length           }
  90.                 UpperCase:Boolean  ;    { True if auto Upcase  }
  91.            var  F1,F10   : boolean);    { Returned true if F1 or F10 }
  92.  
  93.    {-- requires
  94.        Global procedures:
  95.          Say_Cap_Num, Set_Cap_Num, Color, Ck_edit_key, Beep, Get_template }
  96. var
  97.   X,J,LastValue: integer;
  98.   OkChars,temp : set of Char;
  99.   DF           : boolean;
  100.  
  101. {.pa}
  102. {-------------------------- local procedures ---------------------------}
  103.   procedure GotoX;
  104.    begin
  105.      GotoXY(X+Col-1,Row);
  106.    end;
  107.  
  108.   procedure Ck_Cap_Num; { test for caps, numbers, & cursor cntrl }
  109.    var Value : integer;
  110.    begin
  111.       repeat
  112.         Value := Mem[0000:1047];
  113.         if LastValue<>value then
  114.           begin LastValue:=Value; Say_Cap_Num; GotoX; end;
  115.       until keypressed;
  116.    end;
  117.  
  118.   procedure PosX;
  119.     begin
  120.       while copy(template,X,1)<>#95 do
  121.        begin
  122.          Answer:=Answer + copy(template,X,1); X:=X+1; GotoX;
  123.        end;
  124.     end;
  125.  
  126.   procedure Del_Ans;
  127.     begin
  128.       Answer:=''; X:=1; GotoX;
  129.       write(template);  GotoX; PosX;
  130.     end;
  131. {------------------------ end local procedures ------------------------}
  132.  
  133. begin
  134.   if Typ='A'then  OKChars:=[' '..'}']
  135.   else OKChars:=['0'..'9','+','-','.'];
  136.   Temp := OKChars;  color(7,0); DF:= false;
  137.   Case Typ of
  138.     'A','N','$': begin  fillchar(template,80,#95);
  139.                         template:=copy(template,1,Mlen);
  140.                         if Typ='$' then
  141.                          begin
  142.                            X:=0; GotoX; HighVideo; write('$');
  143.                          end;
  144.                  end;
  145.     'F':         begin
  146.                    Get_template(Mlen,template); Mlen := length(template);
  147.                    if copy(template,1,1)<>#95 then DF:= true;
  148.                  end;
  149.  
  150.   end;
  151.  
  152.   if Typ = 'A' then if uppercase then Set_Cap_Num('C',' ','I')
  153.                     else Set_Cap_Num(' ',' ','I')
  154.   else Set_Cap_Num(' ','N',' ');
  155.   Color(7,0);
  156.   Answer := ''; F1:=false; F10:=false;
  157.   if Default<>'' then
  158.     begin
  159.       X:=1; GotoX; write(template); GotoX; write(default);
  160.       Answer:=Default;
  161.     end
  162.   else Del_Ans;
  163.   LastValue:=Mem[0000:1047]; Say_Cap_Num; GotoX;
  164.  
  165.   repeat
  166.     Ck_Cap_Num; read(kbd,Ch);  Color(7,0);
  167.     if (keypressed) and (Ch<>'p') and (Ch<>'q') then Ck_edit_key(Ch);
  168.     if (Typ='F') and (X=1) and (Default<>'') and (Ch<>^1) and (Ch<>#13)
  169.      then Del_Ans;
  170.     case Ch of
  171.        ^[: begin Del_Ans end;     { ESC pressed   }
  172.  
  173.        ^D: begin { Move cursor right : rt-arr }
  174.              X:=X+1;
  175.              if (X>length(Answer)+1) or (X>Mlen) then X:=X-1;
  176.              GotoX;
  177.            end;
  178.  
  179.        ^S: begin { Move cursor left : left-arr }
  180.              if Typ='F' then Del_Ans  else
  181.              begin
  182.                X:=X-1; if X<1 then X:=1;
  183.                GotoX;
  184.              end;
  185.            end;
  186.        ^O: begin { Move cursor to end of line }
  187.               X:=Length(Answer)+1; if X>Mlen then X:=Mlen; GotoX;
  188.            end;
  189.        ^G: begin { Move cursor to beginning of line }
  190.              X:=1; GotoX;
  191.            end;
  192.        ^H: begin { Delete left char: BS }
  193.              if Typ='F' then Del_Ans
  194.              else
  195.                begin
  196.                  X:=X-1;
  197.                  if (Length(Answer)>0) and (X>0)  then
  198.                    begin
  199.                      Delete(Answer,X,1); GotoX;
  200.                      Write(copy(Answer,X,(Length(Answer)-X+1)),#95);
  201.                      GotoX;
  202.                    end
  203.                  else X:=1;
  204.              end; { Typ <> 'F' }
  205.            end;
  206.        #127: begin { Delete }
  207.                Delete(Answer,X,1);
  208.                Write(copy(Answer,X,Length(Answer)-X+1),#95); GotoX;
  209.              end;
  210.         ^a : begin  { F1 pressed }
  211.                F1 := true; Exit := true; Answer:= default;
  212.              end;
  213.         ^M : Exit := true;
  214.         ^j : begin F10 := true; Exit := true; Answer := default; end;
  215.  
  216.     else
  217.     if (length(Answer)+1 <= Mlen) or (not InsertOn) then
  218.     begin   { non-IBM char }
  219.         if Ch in OkChars  then
  220.          begin
  221.           if InsertOn then
  222.           begin
  223.            if length(Answer) < Mlen then
  224.            begin             { OK to insert }
  225.              insert(Ch,Answer,X);
  226.                Case Typ of
  227.                 'A','N','$' : write(copy(Answer,X,Length(Answer)-X+1));
  228.                 'F'         : Write(Ch);
  229.                end; {Case}
  230.            end;        { OK to insert }
  231.           end else     { end InsertOn }
  232.           if X <= Mlen then
  233.           begin
  234.              write(Ch);
  235.              if X>length(Answer) then Answer:=Answer+Ch
  236.              else Answer[X]:=Ch;
  237.           end;  { processing this key }
  238.           if X+1 <= Mlen then X:=X+1;
  239.           if (X > Length(Answer)) and (template[X]<>#95) then PosX;
  240.          end { OkChars }
  241.          else if (Ch<> ^V) then Beep(300,150);
  242.              { beep if invalid char and ch is not Insert key }
  243.         GotoX;
  244.     end;   { non IBM key }
  245.     if (typ<>'F') and (length(Answer)+1 > Mlen) and (Ch <> ^V)
  246.      then  Beep(600,100);
  247.    end;    {   CASE!!!   }
  248.   until Exit = true;
  249.  Color(0,15); X:=1; gotoX; write(Answer);
  250.       { erase part of template that is left }
  251.  X:=length(Answer)+1; GotoX;
  252.  for J:= 1 to Mlen-x+1 do write(' ');
  253.  Exit := false; Color(0,7);
  254.  if (DF) and (length(Answer)=1) then
  255.   begin
  256.     gotoXY(col,row); write(' '); Answer:='';
  257.   end;
  258. end;          { end Input Procedure }